home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / MAIL.SWG / 0007_FIDO Message Numbers.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-02-21  |  6.7 KB  |  263 lines
  1. program MSGNUM;
  2. uses dos,crt;
  3. const version='v1.5';
  4. var sto,
  5.     sfrom,
  6.     daystosave,
  7.     top,
  8.     bottom,
  9.     mtop,
  10.     mbottom,
  11.     keep      :word;
  12.     drv       :byte;
  13.     st,
  14.     path      :string;
  15.     msg,
  16.     save      :array[1..10240] of boolean;
  17.     date      :array[1..10240] of word;
  18.  
  19. Function CurrentDrive:char;
  20. var pthstr:pathstr;
  21. begin
  22.    pthstr:=fexpand('');
  23.    CurrentDrive:=pthstr[1];
  24. end;
  25.  
  26. function mchr(n:byte;ch:char):string;
  27. var a:byte;s:string;
  28. begin
  29.   s:='';
  30.   for a:=1 to n do s:=s+ch;
  31.   mchr:=s;
  32. end;
  33.  
  34. function FDayOfYear(l:longint):word;
  35. var t:datetime;
  36. begin
  37.    unpacktime(l,t);
  38.    t.month:=t.month-1;
  39.    FDayOfYear:=((t.year-1990)*365)
  40.    + (t.year-1988 div 4)
  41.    + (t.month*30) + t.day
  42.    + (  ord(t.month>=1))
  43.    - (2*ord(t.month>=2))
  44.    + (  ord(t.month>=3))
  45.    + (  ord(t.month>=5))
  46.    + (  ord(t.month>=7))
  47.    + (  ord(t.month>=8))
  48.    + (  ord(t.month>=10));
  49. end;
  50.  
  51. Function TodaysDate:word;
  52. var y,m,d,temp:word;dt:datetime;l:longint;
  53. begin
  54.       getdate(y,m,d,temp);
  55.       dt.year:=y;
  56.       dt.month:=m;
  57.       dt.day:=d;
  58.       packtime(dt,l);
  59.       todaysdate:=fdayofyear(l);
  60. end;
  61.  
  62. procedure initvars;
  63. var a:word;
  64. begin
  65.    sto:=1;
  66.    sfrom:=1;
  67.    daystosave:=2;
  68.    keep:=100;
  69.    bottom:=1;
  70.    mbottom:=1;
  71.    mtop:=1;
  72.    top:=1;
  73.    path:='';
  74.    for a:=1 to 10240 do
  75.    begin
  76.       msg[a]:=FALSE;
  77.       save[a]:=FALSE;
  78.       date[a]:=0;
  79.    end;
  80. end;
  81.  
  82. procedure getparams;
  83. var a,b,code:word;parama,temp:string;past:boolean;
  84. begin
  85.    If (paramcount<1) or (paramstr(1)='?') then
  86.    begin
  87.       writeln;
  88.       writeln(' MSGNUM ',version,' -  A Message base renumbering system for
  89. FIDOnet and compatible');      writeln(' message systems.  This is a brute
  90. force handler that is s-l-o-w. But it');      writeln(' uses file handlers
  91. instead of FCBs like RENUM, so is safer. Syntax:');      writeln;
  92.       writeln('    MSGNUM  [switches] [path]');
  93.       writeln;
  94.       writeln(' Switches:');
  95.       writeln;
  96.       writeln('    /Sxx-yy    Save messages xx to yy - keeps those messages
  97. exactly as');      writeln('               they were before, and does NOT
  98. renumber THEM');      writeln('    /Dxx       Messages less than xx days old
  99. will be saved even if they');      writeln('               exceed the /L
  100. paramater');      writeln('    /Kxx       Keeps xx messages in the base, even
  101. if they are older than the');      writeln('               number of days
  102. specified in the /D paramater.');      writeln;
  103.       writeln(' Path MUST be specified.  The path refers to the subdir of the
  104. base to be');      writeln(' renumbered.');
  105.       writeln;
  106.       writeln(' Default is:  MSGNUM /S1-1 /D2 /K100 [path]');
  107.       halt;
  108.    end
  109.    else
  110.    begin
  111.       for a:=1 to paramcount do
  112.       begin
  113.          parama:=paramstr(a);
  114.          If parama[1]='/' then
  115.          begin
  116.             Case upcase(parama[2]) of
  117.             'S':begin
  118.                    past:=FALSE;
  119.                    temp:='';
  120.                    for b:=3 to length(parama) do
  121.                    begin
  122.                       If parama[b]='-' then
  123.                       begin
  124.                          past:=TRUE;
  125.                          val(temp,sfrom,code);
  126.                          temp:='';
  127.                       end
  128.                       else
  129.                       begin
  130.                          temp:=temp+parama[b];
  131.                       end;
  132.                    end;
  133.                    val(temp,sto,code);
  134.                 end;
  135.             'D':begin
  136.                    temp:='';
  137.                    for b:=3 to length(parama) do
  138.                    begin
  139.                       temp:=temp+parama[b];
  140.                    end;
  141.                    val(temp,daystosave,code);
  142.                 end;
  143.             'K':begin
  144.                    temp:='';
  145.                    for b:=3 to length(parama) do
  146.                    begin
  147.                       temp:=temp+parama[b];
  148.                    end;
  149.                    val(temp,keep,code);
  150.                 end;
  151.             end;
  152.          end
  153.          else
  154.          begin
  155.             If path='' then
  156.                for b:=1 to length(parama) do path:=path+parama[b];
  157.             If path[length(path)]<>'\' then path:=path+'\';
  158.             path:=fexpand(path);
  159.          end;
  160.       end;
  161.    end;
  162. end;
  163.  
  164. procedure readfilesin;
  165. var s:searchrec;
  166.     tempword:word;
  167.     tempint:integer;
  168. begin
  169.    Findfirst(path+'*.msg',AnyFile,s);
  170.    While DosError=0 do
  171.    begin
  172.       val(copy(s.name,1,length(s.name)-4),tempword,tempint);
  173.       msg[tempword]:=TRUE;
  174.       save[tempword]:=(tempword>=sfrom) and (tempword<=sto);
  175.       date[tempword]:=FDayOfYear(s.time);
  176.       If tempword<bottom then bottom:=tempword;
  177.       If tempword>top then top:=tempword;
  178.       Findnext(s);
  179.    end;
  180. end;
  181.  
  182. procedure findkeep;
  183. var count:word;td:word;
  184. begin
  185.    count:=1;
  186.    mtop:=top;
  187.    mbottom:=top+1;
  188.    td:=todaysdate;
  189.    repeat
  190.       dec(mbottom);
  191.       If (msg[mbottom]) and (not save[mbottom]) and (mbottom>bottom) then
  192.          inc(count);
  193.    until ((count>=keep) and (date[mbottom]+daystosave<=td)) or
  194. (mbottom<=bottom);end;
  195.  
  196. procedure deleteunwanted;
  197. var a,
  198.     todayyear,
  199.     y,
  200.     m,
  201.     d,
  202.     temp    :word;
  203.     tempstr :string[12];
  204.     f       :file;
  205. begin
  206.    Write('Erasing  No Files!  ');
  207.    for a:=1 to (mbottom-1) do
  208.    begin
  209.       If (msg[a]) and (not save[a]) then
  210.       begin
  211.          str(a,tempstr);
  212.          tempstr:=tempstr+'.MSG';
  213.          assign(f,tempstr);
  214.          Write(mchr(12,#8),mchr(12-length(tempstr),#32)+tempstr);
  215.          erase(f);
  216.          msg[a]:=FALSE;
  217.       end;
  218.    end;
  219.    Writeln(mchr(70-wherex,#32),' ...Done.');
  220. end;
  221.  
  222. procedure renameexisting;
  223. var a,count:word;
  224.     tempstr,countstr:string[12];
  225.     f:file;
  226. begin
  227.    a:=mbottom;
  228.    count:=0;
  229.    Write('Renaming '+mchr(28,#32));
  230.    repeat
  231.       If (msg[a]) and (not save[a]) then
  232.       begin
  233.          tempstr:='';
  234.          str(a,tempstr);
  235.          tempstr:=tempstr+'.MSG';
  236.          assign(f,tempstr);
  237.          inc(count);
  238.          while save[count] do inc(count);
  239.          str(count,countstr);
  240.          countstr:=countstr+'.MSG';
  241.          Write(mchr(28,#8),tempstr,' to
  242. ',countstr,mchr(24-length(tempstr)-length(countstr),#32));         If
  243. (countstr<>tempstr) then rename(f,countstr);      end;
  244.       inc(a);
  245.    until a>top;
  246.    writeln(mchr(70-wherex,#32),' ...Done.');
  247. end;
  248.  
  249. begin
  250.    initvars;
  251.    getparams;
  252.    getdir(0,st);
  253.    chdir(copy(path,1,length(path)-1));
  254.    writeln(' Renumbering directory '+copy(path,1,length(path)-1));
  255.    readfilesin;
  256.    findkeep;
  257.    write(' Deleting Unwanted files.... ');
  258.    deleteunwanted;
  259.    write(' Renaming Remaining files... ');
  260.    renameexisting;
  261.    chdir(st);
  262. end.
  263.